COMMENT ⊗   VALID 00007 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002
C00013 00003	 A mapping function for a E entities
C00015 00004	 Sends a page of stuff, 200 liness at a time
C00016 00005	 Stuff to lookup a word in UNABRD.DIC Takes a word in the attach
C00022 00006	 Routines to exchange 2 pages.
C00025 00007	 A routine to clean up a file.
C00028 ENDMK
C⊗;
;;; A mapping function for a E entities

;;; NIL result for fun means stay on current line, number means go up or down
;;; that amount. T means next line.

(defun e:page-map (fun)
 (em:ecommands '(α - α V))
 (do ((line (em:readonly-var 'line)) (result))
     ((< (em:readonly-var 'lines) line) (em:ecommands '(α V)) 'done)
     (em:ecommands '(α =))
     (setq result (funcall fun (em:tyi-message)))
     (cond ((numberp result)
	    (em:ecommands 
	     (append 
	      (e:make-e-control-number result) '(⊗ ↔))) 
	    (setq line (+ line result)))
	   (result (setq line (1+ line))
		   (em:ecommands '(⊗ ↔))))))

(defun e:set-current-line (cline)
       (em:raw-ecommands (append '(#o2 #o113 #o26 #o27) 
				 cline '(#o26 #o102))))

;;; Sends a page of stuff, 200 liness at a time

(defun e:send-page ()
 (let ((lines (cdr (assq 'lines (em:readonly-vars '(lines))))))
      (let ((n (quotient lines 200.)))
	   (em:ecommands '(α - α V α L))
	   (cond ((not (= 0 (remainder lines 200.)))
		  (setq n (1+ n))))
	   (do ((i n (1- i)))
	       ((= i 0) (em:ecommands '(α V)) 'done)
	       (em:ecommands '(α 2 α 0 α 0 α =))
	       (em:ecommands '(α 2 α 0 α 0 ⊗ ↔))))))

;;; Stuff to lookup a word in UNABRD.DIC Takes a word in the attach
;;; buffer and say αz F

(declare (special e:dir-h))
(array e:unabrd t 235.)

(do ((l 
'(A accordantly actinomeric advisal agitation alem altaite ampelotherapy ancillary anodendron anticritique Aonian apron argel Ascetta
atechnical autocephality azotate balloonful basisphenoid beerhouse beprose Bidens bitterwood board Bothrodendron breediness Buchnera
by calotermitid capripede caryatic cecidiologist Cestida cheese choanosome churchman clart coagitator cointense commot confinedness
contorsive corke counterbuff crateman cruroinguinal curvy dacryocystosyringotomy debatingly degradement denudate detergence dicetyl
diplacusis disharmonism Ditremidae dosimetrist dualin ebulus elderbrotherhood emetomorphine enforcer Epanorthidae equivocal
ethnogeographer exceptionality extending fanfare ferreting firelock floriculture foregleam frangula funambulator gamont Gemmingia
gigglingly glycogenize gracilis grooveless gymnurine hangar heaviness hemoconcentration heteronomy histotrophy hoof huntilite
hyostylic hypotrachelium illocality impregnant incubous inferringly insense interjaculate intrarelation irreportable Jacamerops
jonque Kawchodinne klipdas lackadaisical larrigan lehr lienopancreatic lithopedium lougheen Maba malapropoism marcello maxillojugal
mellifluent Mesosauria microbrachius minding misspend monkism moringaceous multifold myitis nasicorn nephology nineteenfold
nonconformance nonliquidation nonsympathizer numerator octan ombrophyte opsonic orthotypous outjest overdaintiness overrealism oxyphile
palinody papion parling pauperess penetrator perigone pet Philodinidae phrenomagnetism piglet Placoidei pleurogenous poison
polysyllabically postexilian preallotment predwell preprudent primevity progressionism protectible pseudocultural pucka Pygopodes
quatrayle radiolucency reaccord recondense refreshen remitment reservedness retrovert ribbed Romescot rundale salicylic Sarothra
 chematic scranny Seder seminase sergeantship Sharia shrinal sinewiness slangish snakeproof solvend sparver spinsterism spumification
statesmanlike stimy strident subcrepitant substandardize sulphureously superpraise swan synergize tamandu tawdered tenantless
 etrapody thermoneutrality thurify titleboard torulose transformism trichloride tritonymphal Tuesday type unadventurously unblossomed
uncompliableness undenominationalize undescript unerected unfrounced uniformal unleafed unobediently unpretendingness unreticent
unskirted untantalized unwearying urethralgia vanadous verdureless violent vulvovaginitis waxing whirroo witloof xanthophyllous
zac)
      (cdr l))
     (i 0 (+ i 1)))
    ((null l)(setq e:dir-h (- i 1)))
    (store (e:unabrd i) `(,(car l) . ,(+ i 2))))

(defmacro dword (n) `(car (e:unabrd ,n)))
(defmacro dpage (n) `(cdr (e:unabrd ,n)))

(defun e:word-lookup (word)
       (cond ((> (cdar (em:readonly-vars '(attsiz))) 
 		 0) 
 	      (em:ecommands '(α β K))))
       (em:ecommands (append '(α ε u n a b r d // d //)
			     (explode (e:bin-search word)) 
			     '(p ⊗ ↔)))
       (em:ecommands (append '(α β F) (explode word) '(⊗ ↔)))
       'done))

(defun e:Bin-search (word)
 (let ((low 0)
       (high e:dir-h))
      (do ((mid (// (+ low high) 2)
		(// (+ low high) 2)))
	  ((not (< low high))
	   (dpage low))
	  (cond ((eq (dword mid)
		     word)
		 (return (dpage mid)))
		((alphalessp (dword mid) word)
		 (cond ((eq (dword (+ mid 1)) word)
			(return (dpage (+ mid 1))))
		       ((alphalessp word (dword (+ mid 1)))
			(return (dpage mid)))
		       (t (setq low (+ mid 1)))))
		(t (setq high (- mid 1)))))))

;;; Routines to exchange 2 pages.

(defun ↔ fexpr (x)
 (let ((n (car x))
       (m (cadr x)))

      (do ((x (cdr n) (cdr x))
	   (y (cdr m) (cdr y))
	   (max (car n))(min (car n)))
	  ((or (null x)(null y))
 	   (setq n (do ((i max (- i 1))
			(l `(,max) `(,i . ,l)))
		       ((< i min) l))))
	  (setq min (min min (car x)(car y)))
	  (setq max (max max (car x)(car y))))  
 
      (em:ecommands '(α - α v))
      (cond ((numberp n)(e:exchange n m))
	    (t (let ((map (mapcar #'(lambda (x) `(,x . ,x)) n)))
		    (do ((n n (cdr n))
			 (m m (cdr m)) (pos1)(pos2))
			((or (null n)(null m)) 'done)
			(setq pos1 (assoc (car m) map))
			(setq pos2 (do ((map map (cdr map))
					(x (car n)))
				       ((null map) ())
				       (cond ((= x (cdr (car Map)))
					      (return (car map))))))
			(cond ((= (car n) (cdr pos1)))
			      (t 
			       (e:exchange (car n)(cdr pos1)) 
			       (rplaca pos1 (prog1 (car pos2)
						   (rplaca pos2 (car pos1))))))))))
      (em:ecommands '(α v))))

(defun e:exchange (n m)
       (let ((ln 0)
	     (lm 0)
	     (current-page (em:readonly-var `page)))
	    
	    (e:goto n 1)
 (setq ln (em:readonly-var 'lines))
 (em:ecommands (append
		(e:make-e-control-number ln)
		'(α A)))
 (e:goto m 1)
 (setq lm (em:readonly-var 'lines))
 (em:ecommands (append '(α e)
		       (e:make-e-control-number ln)
		       '(⊗ ↔)
		       (e:make-e-control-number lm)
		       '(α a)))
 (e:goto n 1)
 (em:ecommands (append
		'(α e)
		(e:make-e-control-number current-page)
		'(α p)))
 'done)) 
;;; A routine to clean up a file.
;;; The following commands on the first line of a page dispose
;;; of that page:
;;;	↓		deletes page
;;;	→<filename>	sends that page to the end of the file indicated

(defun e:dispose-file ()
       (em:ecommands '(α - α V α 2 α p))
       (do ((pages (- (em:readonly-var 'pages) 1) (- pages 1)))
	   ((= pages 0) (em:ecommands '(α 1 α p α v))
			'done)
	   (e:dispose-page (not (= pages 1)))))

(defun e:dispose-page (flag)		;go to next page flag
 (em:ecommands '(α =))
 (let ((line (em:tyi-message)))
      (do ((l line (cdr l)))
	  ((not (member (car l) '(#o15 #o12))) (setq line l)))
      (cond ((= (car line)  1)		;↓
	     (e:delete-page))
	    ((= (car line) 25.)		;→<filename>
	     (em:ecommands '(α D α ⊗ ↔ α =))
	     (let ((file (car (read-filename ()))))
		  (em:ecommands '(α β D))
		  (e:move-page-to-file file)))
	    (flag (em:ecommands '(α p))))))

(defun e:delete-page ()
       (em:ecommands '(α ∂ α β D)))

;;;	file looks like ((dsk (aid rpg)) foo bar)

(defmacro file-filename (file) `(cadr ,file))
(defmacro file-extension (file) `(caddr ,file))
(defmacro file-project (file) `(car (cadr (car ,file))))
(defmacro file-programmer (file) `(cadr (cadr (car ,file))))

(defun e:move-page-to-file (file)
 (em:ecommands (append '(α ∂ α A α ε)
		       (explode (file-filename file))
		       '(/.)
		       (explode (file-extension file))
		       '(/[)
		       (explode (file-project file))
		       '(/,)
		       (explode (file-programmer file))
		       '(/] // e ⊗ ↔ α X M A R K ⊗ ↔ α H))))


(defun e:switch-file (file)
 (em:ecommands (append '(α ε)
		       (explode (file-filename file))
		       '(/.)
		       (explode (file-extension file))
		       '(/[)
		       (explode (file-project file))
		       '(/,)
		       (explode (file-programmer file))
		       '(/]  // e ⊗ ↔))))